home
***
CD-ROM
|
disk
|
FTP
|
other
***
search
/
Info-Mac 4
/
Info_Mac IV CD-ROM (Pacific HiTech Inc.)(August 1994).iso
/
Development
/
Source
/
DBL Pascal Library
/
CallChain ƒ
/
CallChain.p
< prev
next >
Wrap
Text File
|
1992-11-01
|
9KB
|
340 lines
unit CallChain;
interface
{Returns True so long as depth is within stack, and stack is uncorrupted.}
function GetCallerInfo (depth: Integer; var frame: Ptr; var procName: Str255; var offset: Integer): Boolean;
{Returns True if we got a complete trace.}
function GetStackTrace (startingDepth: Integer; dest: CharsHandle; var destSize: Size): Boolean;
implementation
{A procedure begins (optionally) with a LINK A6,#nnnn instruction, and ends with}
{one of (a) an RTS, (b) a JMP (A0), or (c) an RTD #nnnn. The ending instruction is}
{followed (optionally) by a name and constant data. The name can be in any of three}
{formats (described below). The constant data consists of a word-length byte count}
{followed by the actual data; the count is word-aligned following the name.}
{}
{The name formats are (a) fixed 8-byte, (b) fixed 16-byte, and (c) variable. The}
{16-byte format is used specifically for short class.method names in Object Pascal.}
{Valid characters are in the set [a–zA–Z0–9_%.] (blanks are used to pad fixed-length names).}
{}
{Fixed-8:}
{ First character in range $20–$7F, ignoring MSB.}
{ MSB of second character is always clear.}
{ Name is eight characters long, with trailing blanks trimmed.}
{Fixed-16:}
{ First character in range $20–$7F, ignoring MSB.}
{ MSB of second character is always set.}
{ Stored as two eight-byte names; method followed by class.}
{ Name is constructed as CLASS.METHOD – must insert period between}
{ parts of name after stripping trailing blanks.}
{Variable:}
{ First byte in range $80–$9F, including MSB.}
{ If first byte is $80, then second byte contains actual length in range $01–$FF.}
{ If first byte is $81–$9F, then clearing MSG gives actual length in range $01–$1F.}
{ Length byte(s) is (are) followed by name, without padding.}
function CurrentA6: Ptr;
inline
$2E8E; {move.l a6,(sp)}
function NextFrame (whichFrame: univ Ptr): Ptr;
inline
$205F, {movea.l (sp)+,a0}
$2E90; {move.l (a0),(sp)}
function CallerRA (whichFrame: univ Ptr): Ptr;
inline
$205F, {movea.l (sp)+,a0}
$2EA8, $0004; {move.l 4(a0),(sp)}
function CurrentSP: Ptr;
inline
$2E8F; {move.l sp,(sp)}
function AddressInStack (theAddress: univ Longint): Boolean;
type
LongPtr = ^Longint;
const
CurStackBase = $908;
begin
AddressInStack := (theAddress <= LongPtr(CurStackBase)^) & (theAddress >= Longint(CurrentSP));
end;
type
IntPtr = ^Integer;
const
LINKA6_instruction = $4E56; {this is a two-word instruction}
RTS_instruction = $4E75; {this is a one-word instruction}
JMPatA0_instruction = $4ED0; {this is a one-word instruction}
RTD_instruction = $4E74; {this is a two-word instruction}
HowFar = 32766;
function MaybeFindName (startingAt: univ Longint): Ptr;
var
where, stopAt: Longint;
begin
stopAt := startingAt + HowFar;
where := startingAt;
MaybeFindName := nil;
while where < stopAt do
begin
case IntPtr(where)^ of
LINKA6_instruction:
Leave;
RTS_instruction, JMPatA0_instruction:
begin
MaybeFindName := Ptr(where + SIZEOF(Integer));
Leave;
end;
RTD_instruction:
begin
MaybeFindName := Ptr(where + 2 * SIZEOF(Integer));
Leave;
end;
otherwise
;
end;
where := where + SIZEOF(Integer);
end;
end; {MaybeFindName}
function AddressInHeap (where: univ Ptr): Boolean;
var
theZone: THz;
begin
theZone := GetZone;
AddressInHeap := (ORD(where) >= ORD(@theZone^.heapData)) & (ORD(where) < ORD(theZone^.bkLim));
end;
type
CharPtr = ^SignedByte;
function GetName (where: univ Longint; var theName: Str255): Boolean;
function CopyName (start: univ Longint; expectedLength: Integer; howManyMSBs: Integer; dest: StringPtr): Boolean;
procedure Fail;
begin
CopyName := False;
Exit(CopyName);
end; {Fail}
const
ValidChars = ['a'..'z', 'A'..'Z', '0'..'9', '_', '%', '.', ' '];
var
where: Longint;
i, actualLength: Integer;
theChar: Char;
begin {CopyName}
where := start;
actualLength := expectedLength;
for i := 1 to expectedLength do
begin
theChar := Char(CharPtr(where)^);
if (i > howManyMSBs) & BTST(theChar, 7) then
Fail;
theChar := Char(BAND(theChar, $7F));
if theChar in ValidChars then
begin
if (actualLength = expectedLength) & (theChar = ' ') then
actualLength := i - 1;
{$PUSH}
{$R-}
{Turn off range checking because string length isn’t yet set…}
dest^[i] := theChar;
{$POP}
where := where + SIZEOF(SignedByte);
end
else
Fail;
end;
{$PUSH}
{$R-}
dest^[0] := CHR(actualLength);
{$POP}
CopyName := True;
end; {CopyName}
procedure NotAName;
begin
theName := '';
GetName := False;
Exit(GetName);
end;
var
name2: string[8];
begin {GetName}
GetName := True;
if not AddressInHeap(where) then
NotAName;
case BAND(CharPtr(where)^, $FF) of
$20..$7F, $A0..$FF:
if BTST(CharPtr(where + SIZEOF(SignedByte))^, 7) then
begin {fixed-16}
if CopyName(where, 8, 2, @name2) & CopyName(where + 8 * SIZEOF(SignedByte), 8, 0, @theName) then
theName := CONCAT(theName, '.', name2)
else
NotAName;
end
else
begin {fixed-8}
if not CopyName(where, 8, 1, @theName) then
NotAName;
end;
$80:
begin {variable, 1–255 char}
if not CopyName(where + 2 * SIZEOF(SignedByte), BAND(CharPtr(where + SIZEOF(SignedByte))^, $7F), 0, @theName) then
NotAName;
end;
$81..$9F:
begin {variable, 1–31 char}
if not CopyName(where + SIZEOF(SignedByte), BAND(CharPtr(where)^, $7F), 0, @theName) then
NotAName;
end;
otherwise
NotAName;
end;
end; {GetName}
function MaybeFindEntry (startingAt: univ Longint): Ptr;
var
where, stopAt: Longint;
begin
stopAt := startingAt - HowFar;
where := startingAt;
MaybeFindEntry := nil;
while where > stopAt do
begin
case IntPtr(where)^ of
LINKA6_instruction:
if IntPtr(where + SIZEOF(Integer))^ < 0 then
begin {• This could give spurious positives.}
MaybeFindEntry := Ptr(where);
Leave;
end;
RTS_instruction, JMPatA0_instruction, RTD_instruction:
Leave; {• This could give spurious negatives.}
otherwise
;
end;
where := where - SIZEOF(Integer);
end;
end; {MaybeFindEntry}
function GetCallerInfo (depth: Integer; var frame: Ptr; var procName: Str255; var offset: Integer): Boolean;
procedure Fail;
begin
GetCallerInfo := False;
frame := nil;
procName := '';
offset := 0;
Exit(GetCallerInfo);
end; {Fail}
var
frameAddress, procReturn, procEntry: Ptr;
i: Integer;
begin {GetCallerInfo}
GetCallerInfo := True; {We’ll change this later, if we fail…}
frameAddress := CurrentA6;
for i := 1 to depth do
if not AddressInStack(frameAddress) then
Fail
else
frameAddress := NextFrame(frameAddress);
frame := frameAddress;
procReturn := CallerRA(frameAddress);
if not GetName(MaybeFindName(procReturn), procName) then
Fail;
procEntry := MaybeFindEntry(procReturn);
if procEntry <> nil then
offset := ORD(procReturn) - ORD(procEntry)
else
offset := 0;
end; {GetCallerInfo}
function GetStackTrace (startingDepth: Integer; dest: CharsHandle; var destSize: Size): Boolean;
procedure MakeHex (num: univ Longint; dest: CharsPtr; digits: Integer);
var
i, digit: Integer;
begin
for i := digits - 1 downto 0 do
begin
digit := num mod 16;
if digit < 10 then
dest^[i] := CHR(digit + ORD('0'))
else
dest^[i] := CHR(digit + ORD('A') - 10);
num := num div 16;
end;
end; {MakeHex}
const
addSize = 15; {8 digits, space, '+', 4 digits, CR}
var
i: Integer;
aFrame: Ptr;
aName: Str255;
aNameLength: Integer;
anOffset: Integer;
stillOK: Boolean;
outSize: Size;
outPtr: CharPtr;
begin {GetStackTrace}
GetStackTrace := True;
outPtr := CharPtr(dest^);
outSize := 0;
i := startingDepth + 1;
repeat
stillOK := GetCallerInfo(i, aFrame, aName, anOffset);
if stillOK then
begin
aNameLength := length(aName);
if outSize + aNameLength + addSize < destSize then
begin
MakeHex(aFrame, CharsPtr(outPtr), 8);
outPtr := CharPtr(ORD(outPtr) + 8);
outPtr^ := ORD(' ');
outPtr := CharPtr(ORD(outPtr) + SIZEOF(SignedByte));
BlockMove(@aName[1], Ptr(outPtr), aNameLength);
outPtr := CharPtr(ORD(outPtr) + aNameLength);
outPtr^ := ORD('+');
outPtr := CharPtr(ORD(outPtr) + SIZEOF(SignedByte));
MakeHex(anOffset, CharsPtr(outPtr), 4);
outPtr := CharPtr(ORD(outPtr) + 4);
outPtr^ := 13;
outPtr := CharPtr(ORD(outPtr) + SIZEOF(SignedByte));
outSize := ORD(outPtr) - ORD(dest^);
end
else
begin
GetStackTrace := False;
Leave;
end;
end
else
Leave;
i := i + 1;
until False;
destSize := outSize;
end; {GetStackTrace}
end.